;;;
;;; NeHe Tutorials in Clozure CL
;;;
;;; Author: John M. Miller <millejoh@mac.com>
;;;
;;;

(in-package :nehe)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (enable-gl-type-syntax)
  (use-interface-dir :gl)
  (open-shared-library "/Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/OpenGL.framework/OpenGL"))

;;;
;;; Tutorial #1 (actually, basic-gl-renderer is tutorial #1
;;; but it seems more chic to refer to it as 'support.')
;;;

(defclass nehe01 (basic-gl-renderer)
  ()
  (:metaclass ns:+ns-object))

(defmethod draw-scene ((view nehe01))
  (#_glLoadIdentity)
  (#_glTranslatef -1.5 0.0 -6.0)
  (with-gl #$GL_TRIANGLES
    (#_glVertex3f 0.0 1.0 0.0)
    (#_glVertex3f -1.0 -1.0 0.0)
    (#_glVertex3f 1.0 -1.0 0.0))
  (#_glTranslatef 3.0 0.0 0.0)
  (with-gl #$GL_QUADS
    (#_glVertex3f -1.0 1.0 0.0)
    (#_glVertex3f 1.0 1.0 0.0)
    (#_glVertex3f 1.0 -1.0 0.0)
    (#_glVertex3f -1.0 -1.0 0.0))
  (#_glFlush))

;;;
;;; Tutorial #2
;;;

(defclass nehe02 (basic-gl-renderer)
  ()
  (:metaclass ns:+ns-object))

(defun gl-vertex (gl-vec)
  (#_glVertex3fv (get-pointer gl-vec)))

(defmethod draw-scene ((view nehe02))
  (#_glLoadIdentity)
  (#_glTranslatef -1.5 0.0 -6.0)
  (with-gl #$GL_TRIANGLES
    (#_glColor3f 1.0 0.0 0.0)
    (#_glVertex3f 0.0 1.0 0.0)
    (#_glColor3f 0.0 1.0 0.0)
    (#_glVertex3f -1.0 -1.0 0.0)
    (#_glColor3f 0.0 0.0 1.0)
    (#_glVertex3f 1.0 -1.0 0.0))
  (#_glTranslatef 3.0 0.0 0.0)
  (#_glColor3f 0.5 0.5 1.0)
  (with-gl #$GL_QUADS
    (let ((v0 (%gl-vector -1.0 1.0 0.0))
          (v1 (%gl-vector 1.0 1.0 0.0))
          (v2 (%gl-vector 1.0 -1.0 0.0))
          (v3 (%gl-vector -1.0 -1.0 0.0)))
      (gl-vertex v0)
      (gl-vertex v1);(#_glVertex3f 1.0 1.0 0.0)
      (gl-vertex v2);(#_glVertex3f 1.0 -1.0 0.0)
      (gl-vertex v3)));(#_glVertex3f -1.0 -1.0 0.0)))
  (#_glFlush))

;;;
;;; Tutorial #3
;;;

(defclass nehe03 (basic-gl-renderer)
  ((rtri :accessor rtri :initform 0.0)
   (rquad :accessor rquad :initform 0.0))
  (:metaclass ns:+ns-object))

(defmethod draw-scene ((view nehe03))
  (with-slots (rtri rquad) view
    (#_glLoadIdentity)
    (#_glTranslatef -1.5 0.0 -6.0)
    (#_glRotatef rtri 0.0 1.0 0.0) ; Rotate along Y-axis
    (with-gl #$GL_TRIANGLES
      (#_glColor3f 1.0 0.0 0.0)
      (#_glVertex3f 0.0 1.0 0.0)
      (#_glColor3f 0.0 1.0 0.0)
      (#_glVertex3f -1.0 -1.0 0.0)
      (#_glColor3f 0.0 0.0 1.0)
      (#_glVertex3f 1.0 -1.0 0.0))
    (#_glLoadIdentity)
    (#_glTranslatef 1.5 0.0 -6.0)
    (#_glColor3f 0.5 0.5 1.0)
    (#_glRotatef rquad 1.0 0.0 0.0) ; Rotate along X-axis
    (with-gl #$GL_QUADS
      (#_glVertex3f -1.0 1.0 0.0)
      (#_glVertex3f 1.0 1.0 0.0)
      (#_glVertex3f 1.0 -1.0 0.0)
      (#_glVertex3f -1.0 -1.0 0.0))
    (#_glFlush)
    (incf rtri 0.2)
    (decf rquad 0.15)))

;;;
;;; Tutorial #4
;;;

(defclass nehe04 (nehe03)
  ()
  (:metaclass ns:+ns-object))

(defmethod draw-scene ((view nehe04))
  (with-slots (rtri rquad) view
    (#_glLoadIdentity)
    (#_glTranslatef -1.5 0.0 -6.0)
    (#_glRotatef rtri 0.0 1.0 0.0)
    (with-gl #$GL_TRIANGLES
      (#_glColor3f 1.0 0.0 0.0)      (#_glVertex3f 0.0 1.0 0.0)
      (#_glColor3f 0.0 1.0 0.0)      (#_glVertex3f -1.0 -1.0 1.0)
      (#_glColor3f 0.0 0.0 1.0)      (#_glVertex3f 1.0 -1.0 1.0)
      (#_glColor3f 1.0 0.0 0.0)      (#_glVertex3f 0.0 1.0 0.0)
      (#_glColor3f 0.0 0.0 1.0)      (#_glVertex3f 1.0 -1.0 1.0) 
      (#_glColor3f 0.0 1.0 0.0)      (#_glVertex3f 1.0 -1.0 -1.0)
      (#_glColor3f 1.0 0.0 0.0)      (#_glVertex3f 0.0 1.0 0.0)
      (#_glColor3f 0.0 1.0 0.0)      (#_glVertex3f 1.0 -1.0 -1.0)
      (#_glColor3f 0.0 0.0 1.0)      (#_glVertex3f -1.0 -1.0 -1.0)
      (#_glColor3f 1.0 0.0 0.0)      (#_glVertex3f 0.0 1.0 0.0)
      (#_glColor3f 0.0 0.0 1.0)      (#_glVertex3f -1.0 -1.0 -1.0)
      (#_glColor3f 0.0 1.0 0.0)      (#_glVertex3f -1.0 -1.0 1.0))
    (#_glLoadIdentity)
    (#_glTranslatef 1.5 0.0 -7.0)
    (#_glRotatef rquad 1.0 1.0 1.0)
    (with-gl #$GL_QUADS
      (#_glColor3f 1.0 0.5 0.0)
      (#_glVertex3f 1.0 -1.0 1.0)
      (#_glVertex3f -1.0 -1.0 1.0)
      (#_glVertex3f -1.0 -1.0 -1.0)
      (#_glVertex3f 1.0 -1.0 -1.0)
      
      (#_glColor3f 1.0 0.0 0.0)
      (#_glVertex3f 1.0 1.0 1.0)
      (#_glVertex3f -1.0 1.0 1.0)
      (#_glVertex3f -1.0 -1.0 1.0)
      (#_glVertex3f 1.0 -1.0 1.0)
      
      (#_glColor3f 1.0 1.0 0.0)
      (#_glVertex3f 1.0 -1.0 -1.0)
      (#_glVertex3f -1.0 -1.0 -1.0)
      (#_glVertex3f -1.0 1.0 -1.0)
      (#_glVertex3f 1.0 1.0 -1.0)

      (#_glColor3f 0.0 0.0 1.0)
      (#_glVertex3f -1.0 1.0 1.0)
      (#_glVertex3f -1.0 1.0 -1.0)
      (#_glVertex3f -1.0 -1.0 -1.0)
      (#_glVertex3f -1.0 -1.0 1.0)

      (#_glColor3f 1.0 0.0 1.0)
      (#_glVertex3f 1.0 1.0 -1.0)
      (#_glVertex3f 1.0 1.0 1.0)
      (#_glVertex3f 1.0 -1.0 1.0)
      (#_glVertex3f 1.0 -1.0 -1.0))
    (#_glFlush)
    (incf rtri 0.2)
    (decf rquad 0.15)))

;;;
;;; Tutorial #6 (Texture mapping)
;;;

(defparameter *the-texture* "file:///Users/millejoh/Applications/DreamingTree/data/BoxImg01.jpg")
(defparameter *block-gel*   "file:///Users/millejoh/Applications/DreamingTree/data/Block-Gel.png")
(defparameter *planet*      "file:///Users/millejoh/Applications/DreamingTree/data/planet.png")
(defparameter *glass*       "file:///Users/millejoh/Applications/DreamingTree/data/Glass.bmp")

(defclass nehe05 (basic-gl-renderer)
  ((xrot :accessor xrot :initform 0.0)
   (yrot :accessor yrot :initform 0.0)
   (zrot :accessor zrot :initform 0.0)
   (texture :accessor texture :initform 0))
  (:metaclass ns:+ns-object))


(defmethod init :after ((view nehe05))
  (#_glEnable #$GL_TEXTURE_RECTANGLE_ARB)
  (setf (texture view) (make-gltexture-from-url-string *the-texture*)))

(defun draw-cube (twidth theight)
  "Assumes the GLContext has been set!"
  (let ((v0 #{1.0 1.0 1.0})
        (v1 #{-1.0 1.0 1.0})
        (v2 #{-1.0 -1.0 1.0})
        (v3 #{1.0 -1.0 1.0})
        (v4 #{1.0 -1.0 -1.0})
        (v5 #{1.0 1.0 -1.0})
        (v6 #{-1.0 1.0 -1.0})
        (v7 #{-1.0 -1.0 -1.0}))
    (with-gl #$GL_QUADS
      ;; Front Face
      (#_glNormal3f 0.0 0.0 1.0)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v2)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v3)
      (#_glTexCoord2f twidth theight)  (gl-vertex v0)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v1)
      ;; Back Face
      (#_glNormal3f 0.0 0.0 -1.0)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v7)
      (#_glTexCoord2f twidth theight)  (gl-vertex v6)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v5)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v4)
      ;; Top Face
      (#_glNormal3f 0.0 1.0 0.0)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v6)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v1)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v0)
      (#_glTexCoord2f twidth theight)  (gl-vertex v5)
      ;; Bottom Face
      (#_glNormal3f 0.0 -1.0 0.0)
      (#_glTexCoord2f twidth theight)  (gl-vertex v4)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v7)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v2)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v3)
      ;; Right Face
      (#_glNormal3f 1.0 0.0 0.0)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v4)
      (#_glTexCoord2f twidth theight)  (gl-vertex v5)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v0)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v3)
      ;; Left Face
      (#_glNormal3f -1.0 0.0 0.0)
      (#_glTexCoord2f 0.0 0.0)         (gl-vertex v2)
      (#_glTexCoord2f twidth 0.0)      (gl-vertex v1)
      (#_glTexCoord2f twidth theight)  (gl-vertex v6)
      (#_glTexCoord2f 0.0 theight)     (gl-vertex v7))))

(defmethod draw-scene ((view nehe05))
  (with-slots (xrot yrot zrot texture) view
    (#_glLoadIdentity)
    (#_glTranslatef 0.0 0.0 -10.0)
    (#_glRotatef xrot 1.0 0.0 0.0)
    (#_glRotatef yrot 0.0 1.0 0.0)
    (#_glRotatef zrot 0.0 0.0 1.0)
    ;(#_glColor3f 0.0 0.0 0.0)
    (#_glBindTexture #$GL_TEXTURE_2D (gltexture-name texture))
    (draw-cube (gltexture-width texture) (gltexture-height texture))
    (incf xrot 0.3)
    (incf yrot 0.2)
    (incf zrot 0.4)))

;;;
;;; Tutorial #6 - Texture mapping, blending, lighting, and user events
;;;

(defclass nehe06 (basic-gl-renderer)
  ((xrot :accessor xrot :initarg :xrot :initform 0.0)
   (xspeed :accessor xspeed :initarg :xspeed :initform 0.2)
   (yrot :accessor yrot :initarg :yrot :initform 0.0)
   (yspeed :accessor yspeed :initarg :yspeed :initform 0.3)
   (z :accessor z :initform -5.0)
   (filter :accessor filter :initform 0)
   (ambient-light :accessor ambient-light :initform  #{0.5 0.5 0.5 1.0})
   (diffuse-light :accessor diffuse-light :initform #{1.0 1.0 1.0 1.0})
   (diffuse-light-position :accessor diffuse-light-position :initform #{0.0 0.0 2.0 1.0})
   (enable-lights :accessor enable-lights :initform nil)
   (enable-blend :accessor enable-blend :initform nil)
   (textures :accessor textures :initform nil))
  (:metaclass ns:+ns-object))

;; This doesn't seem very portable.
(defparameter *left-arrow* 63234)
(defparameter *right-arrow* 63235)
(defparameter *up-arrow* 63232)
(defparameter *down-arrow* 63233)
(defparameter *page-up* 63276)
(defparameter *page-down* 63277)

(objc:defmethod (#/keyUp: :void) ((view nehe06) event)
  (let ((chars (ccl::lisp-string-from-nsstring (#/charactersIgnoringModifiers event))))
    (let* ((char (char chars 0))
           (code (char-code char)))
      (cond ((char= char #\L) (progn
                                (setf (enable-lights view) (not (enable-lights view)))
                                (if (not (enable-lights view))
                                  (#_glDisable #$GL_LIGHTING)
                                  (#_glEnable #$GL_LIGHTING))))
            ((char= char #\F) (progn
                                (if (>= (filter view) 2)
                                  (setf (filter view) 0)
                                  (incf (filter view)))))
            ((char= char #\B) (progn
                                (setf (enable-blend view) (not (enable-blend view)))
                                (if (enable-blend view)
                                  (progn
                                    (#_glEnable #$GL_BLEND)
                                    (#_glDisable #$GL_DEPTH_TEST)
                                    (setf (filter view) 2))
                                  (progn
                                    (#_glDisable #$GL_BLEND)
                                    (#_glEnable #$GL_DEPTH_TEST)))))
            ((char= char #\A) (start-animation view))
            ((char= char #\a) (stop-animation view))
            ((= code *page-up*)
             (decf (z view) 0.02))
            ((= code *page-down*)
             (incf (z view) 0.02))
            ((= code *up-arrow*)
             (decf (xspeed view) 0.01))
            ((= code *down-arrow*)
             (incf (xspeed view) 0.01))
            ((= code *right-arrow*)
             (incf (yspeed view) 0.01))
            ((= code *left-arrow*)
             (decf (yspeed view) 0.01))))))

(objc:defmethod (#/acceptsFirstResponder :<BOOL>) ((view nehe06))
  t)

(defmethod init :after ((view nehe06))
  (#_glColor4f 1.0 1.0 1.0 0.5)
  (#_glBlendFunc #$GL_SRC_ALPHA #$GL_ONE)
  (#_glEnable #$GL_TEXTURE_RECTANGLE_ARB)
  (if (enable-lights view)
    (#_glEnable #$GL_LIGHTING)
    (#_glDisable #$GL_LIGHTING))
  (pushnew (make-instance 'texture 
             :source *the-texture*
             :glview view
             :min-filter #$GL_NEAREST
             :mag-filter #$GL_NEAREST)
           (textures view))
  (pushnew (make-instance 'texture
             :source *the-texture*
             :glview view
             :min-filter #$GL_LINEAR
             :mag-filter #$GL_LINEAR)
           (textures view))
  (pushnew (make-instance 'texture
             :source *glass*
             :glview view
             :min-filter #$GL_LINEAR
             :mag-filter #$GL_LINEAR)
           (textures view))
  (mapc #'load-texture (textures view))
  (with-slots (ambient-light diffuse-light diffuse-light-position) view
    (#_glLightfv #$GL_LIGHT1 #$GL_AMBIENT (get-pointer ambient-light))
    (#_glLightfv #$GL_LIGHT1 #$GL_DIFFUSE (get-pointer diffuse-light))
    (#_glLightfv #$GL_LIGHT1 #$GL_POSITION (get-pointer diffuse-light-position))
    (#_glEnable #$GL_LIGHT1)))

(defmethod draw-scene ((view nehe06))
  (#_glEnable #$GL_DEPTH_TEST)
  (#_glDepthFunc #$GL_NEVER)
  ;(#_glDisable #$GL_DEPTH_TEST)
  (with-slots (xrot yrot xspeed yspeed z textures filter) view
    (#_glLoadIdentity)
    (#_glTranslatef 0.0 0.0 z)
    (#_glRotatef xrot 1.0 0.0 0.0)
    (#_glRotatef yrot 0.0 1.0 0.0)
    (#_glBindTexture #$GL_TEXTURE_2D (binding (nth filter textures)))
    (draw-cube (width (nth filter textures)) (height (nth filter textures)))
    (incf xrot xspeed)
    (incf yrot yspeed)
    (when (> xrot 360.0)
      (setq xrot 0.0))
    (when (> yrot 360.0)
      (setq yrot 0.0))))

;;;
;;; Tutorial #7 - Okay, now I am way out of sync since
;;; tutorial #6 was actually nehe tutorials #7 and #8
;;; combined.

(defstruct star
  color
  dist
  angle)

(defclass nehe07 (basic-gl-renderer)
  ((twinkle-p :accessor twinkle-p :initform nil)
   (stars :accessor stars :initform nil)
   (star-count :initarg :start-count :initform 50)
   (zoom :accessor zoom :initform -15.0)
   (tilt :accessor tilt :initform 90.0)
   (spin :accessor spin :initform 0.0)
   (textures :accessor textures :initform nil))
  (:metaclass ns:+ns-object))

(defmethod init ((view nehe07))
  (determine-capabilities view)
  (setf (textures view) (make-instance 'texture :source *block-gel*
                          :glview view))
  (load-texture (textures view))
  (#_glEnable #$GL_TEXTURE_RECTANGLE_ARB)
  (#_glShadeModel #$GL_SMOOTH)
  (#_glClearColor 0.0 0.0 0.0 0.5)
  (#_glClearDepth 1.0d0)
  (#_glHint #$GL_PERSPECTIVE_CORRECTION_HINT #$GL_NICEST)
  (#_glBlendFunc #$GL_SRC_ALPHA #$GL_ONE)
  (#_glEnable #$GL_BLEND))

(defmethod init :after ((view nehe07))
  (with-slots (stars star-count) view
    (setf stars (make-array star-count :element-type (type-of (make-star))))
    (iter (for i from 0 below star-count)
          (after-each (setf (aref stars i)
                            (make-star :color (%gl-vector (random 1.0) (random 1.0) (random 1.0) 1.0)
                                       :angle 0.0
                                       :dist (* (/ i star-count) 5.0)))))))

(defmethod draw-scene ((view nehe07))
  (let ((v0 #{-1.0 -1.0 0.0})
        (v1 #{ 1.0 -1.0 0.0})
        (v2 #{ 1.0  1.0 0.0})
        (v3 #{ -1.0 1.0 0.0}))
    (with-slots (textures stars zoom tilt twinkle-p spin star-count) view
      (#_glBindTexture #$GL_TEXTURE_2D (binding textures))
      (iter (for star in-vector stars)
            (for i upfrom 0)
            (after-each (#_glLoadIdentity)
                        (#_glTranslatef 0.0 0.0 zoom)
                        (#_glRotatef tilt 1.0 0.0 0.0)
                        (#_glRotatef (star-angle star) 0.0 1.0 0.0)
                        (#_glTranslatef (star-dist star) 0.0 0.0)
                        ;; According to Nehe the follow rotates are to ensure that
                        ;; the 2D texture is always facing towards the viewer
                        (#_glRotatef (- (star-angle star)) 0.0 1.0 0.0)
                        (#_glRotatef (- tilt) 1.0 0.0 0.0)
                        (when twinkle-p
                          (#_glColor4fv (get-pointer (star-color star)))
                          (with-gl #$GL_QUADS
                            (#_glTexCoord2f 0.0 0.0)               (gl-vertex v0)
                            (#_glTexCoord2f (width textures) 0.0)  (gl-vertex v1)
                            (#_glTexCoord2f (width textures)
                                            (height textures))     (gl-vertex v2)
                            (#_glTexCoord2f 0.0 (height textures)) (gl-vertex v3)))
                        (#_glRotatef spin 0.0 0.0 1.0)
                        (#_glColor4fv (get-pointer (star-color star)))
                        (with-gl #$GL_QUADS
                          (#_glTexCoord2f 0.0 0.0)               (gl-vertex v0)
                          (#_glTexCoord2f (width textures) 0.0)  (gl-vertex v1)
                          (#_glTexCoord2f (width textures)
                                          (height textures))     (gl-vertex v2)
                          (#_glTexCoord2f 0.0 (height textures)) (gl-vertex v3))
                        (incf spin 0.1) (if (> spin 360.0) (setf spin 0.0))
                        (incf (star-angle star) (coerce (/ i star-count) 'single-float))
                        (if (> (star-angle star) 360.0) (setf (star-angle star) 0.0))
                        (decf (star-dist star) 0.01)
                        (when (< (star-dist star) 0.0)
                          (incf (star-dist star) 5.0)
                          (setf (star-color star) (%gl-vector (random 1.0) (random 1.0) (random 1.0) 1.0))))))))

(objc:defmethod (#/keyUp: :void) ((view nehe07) event)
  (let ((chars (ccl::lisp-string-from-nsstring (#/charactersIgnoringModifiers event))))
    (let* ((char (char chars 0))
           (code (char-code char)))
      (cond ((char= char #\T) (setf (twinkle-p view) (not (twinkle-p view))))
            ((char= char #\A) (start-animation view))
            ((char= char #\a) (stop-animation view))
            ((= code *page-up*)
             (decf (zoom view) 0.2))
            ((= code *page-down*)
             (incf (zoom view) 0.2))
            ((= code *up-arrow*)
             (decf (tilt view) 0.5))
            ((= code *down-arrow*)
             (incf (tilt view) 0.5))))))

(objc:defmethod (#/acceptsFirstResponder :<BOOL>) ((view nehe07))
  t)


;;;
;;; Now let's try some of the Chipmunk tutorials
;;;

(defparameter *dt* (/ 1.0d0 60.0d0))

(defclass chipmunk-demo (basic-gl-renderer)
  ((space :accessor space))
  (:metaclass ns:+ns-object))

(defmethod animation-timer ((view chipmunk-demo))
  (when view
    (with-slots (timer current-time) view
      (loop
        (cp:step-simulation (space view) 1)
        ;(format t "Stepping simulation.~%")
        (with-macptrs ((context (#/openGLContext view))
                       (bounds (#/bounds view)))
          (when context
            (#/makeCurrentContext context)
            (#/drawRect: view bounds)
            (#/flushBuffer context)))
        (#/clearCurrentContext ns:ns-opengl-context)
        (sleep (/ 1.0 60.0))))))

(objc:defmethod (#/reshape :void) ((gl-view chipmunk-demo))
  (let* ((frame (#/frame gl-view))
         (width (ns:ns-rect-width frame))
         (height (ns:ns-rect-height frame)))
    (#_glViewport 0 0 (truncate width) (truncate height))
    (with-matrix-mode #$GL_PROJECTION
      (#_glLoadIdentity)
      (#_glOrtho -320.0d0 320.0d0 -240.0d0 240.0d0 -1.0d0 1.0d0)
      (#_glTranslatef 0.5 0.5 0.0))
    (#_glLoadIdentity)))

(defmethod draw ((shape cp:segment-shape))
  (let* ((pos (cp:pos shape))
         (rot (cp:rotation shape))
         (start (cp:start-point shape))
         (end (cp:end-point shape))
         (a (cp:cpv+ pos (cp:cpvrotate start rot)))
         (b (cp:cpv+ pos (cp:cpvrotate end rot))))
    (with-gl #$GL_LINES
      (#_glVertex2d (cpv.x a) (cpv.y a))
      (#_glVertex2d (cpv.x b) (cpv.y b)))))

(defmethod draw ((shape cp:circle-shape))
  (let* ((pos (cp:pos shape))
         (rot (cp:rotation shape))
         (angle (cp:angle (body shape)))
         (center (cp:center shape))
         (radius (cp:radius shape))
         (c (cp:cpv+ pos (cp:cpvrotate center rot)))
         (segs 15) ; Increase this to have smoother circles
         (coef (/ (* 2.0d0 PI) segs)))
;    (format t "Circle pos (~A,~A), rot (~A,~A), center (~A,~A), c (~A,~A)~%" (cpv.x pos) (cpv.y pos)
;            (cpv.x rot) (cpv.y rot) (cpv.x center) (cpv.y center)  (cpv.x c) (cpv.y c))
    (with-gl #$GL_LINE_STRIP
      (dotimes (n (1+ segs))
        (let ((rads (* n coef)))
          (let ((x (+ (* radius (cos (+ rads angle))) (cp:cpv.x c)))
                (y (+ (* radius (sin (+ rads angle))) (cp:cpv.y c))))
            ;(format t "Vertex @ (~A, ~A)~%" x y)
            (#_glVertex2d x y))))
      (#_glVertex2d (cp:cpv.x c) (cp:cpv.y c)))))

(defmethod draw ((shape cp:polygon-shape))
  (let* ((pos (cp:pos shape))
         (rot (cp:rotation shape))
         (verts (cp:vertices shape)))
    ;(format t "Drawing polygon ~A at (~A, ~A).~%" shape (cpv.x pos) (cpv.y pos))
    (with-gl #$GL_LINE_LOOP
      (dolist (v verts)
        (let ((v0 (cp:cpv+ pos (cp:cpvrotate (apply #'cp:cpv v) rot))))
          ;(format t "|Rotation:(~A,~A) Vertex:(~A, ~A)|  " (cpv.x rot) (cpv.y rot) (cpv.x v0) (cpv.y v0))
          (#_glVertex2d (cpv.x v0) (cpv.y v0)))))))

(defmethod draw-scene ((view chipmunk-demo))
  (#_glColor3f 1.0 1.0 1.0)
  (dolist (shape (cp:shapes (space view)))
    (draw shape)))

(defmethod init :after ((view chipmunk-demo))
  (let* ((space (make-instance 'cp:space :gravity (cpv 0 -10) :time-step *dt*))
         (static-body (make-instance 'body :mass +infinity+ :moment +infinity+))
         (floor (make-instance 'segment-shape :body static-body
                  :start-point (cpv -100 0)
                  :end-point (cpv 100 0)
                  :thickness 1.0d0
                  :elasticity 1.0d0
                  :friction 1.0d0))
         (body1 (make-instance 'body
                 :mass 1.0
                 :moment (moment-for-circle 1.0 0.0 5.0 +cpvzero+)
                 :position (cpv 0 100)))
         (poly-body (make-instance 'body
                      :mass 1.0
                      :moment (moment-for-polygon 1.0 '((-15 -15)
                                                        (-15 15)
                                                        (15 15)
                                                        (15 -15))
                                                  cp:+cpvzero+)
                      :position (cpv 0 240)))
         (box (make-instance 'cp:polygon-shape 
                :name "Box"
                :body poly-body
                :vertices '((-15 -15)
                            (-15 15)
                            (15 15)
                            (15 -15))
                :offset +cpvzero+
                :elasticity 0.0d0 :friction 1.5d0))
         (circle (make-instance 'circle-shape :body body1
                   :name "Circle"
                   :radius 5.0
                   :offset +cpvzero+)))
    (add-static-object space static-body)
    (add-static-object space floor)
    (add-object space body1)
    (add-object space circle)
    (add-object space poly-body)
    (add-object space box)
    (setf (space view) space)))

;;;; ---- ;;;;

(defclass chipmunk-stairs (chipmunk-demo)
  ((space :accessor space))
  (:metaclass ns:+ns-object))

(defmethod init :after ((view chipmunk-stairs))
  (let ((static-body (make-instance 'cp:body 
                       :mass cp:+infinity+ 
                       :moment cp:+infinity+))
        (space (make-instance 'cp:space :gravity (cpv 0 -10)
                 :time-step *dt*)))
    (cp:add-static-object space static-body)
    (let* ((shape1 (make-instance 'cp:segment-shape 
                     :body static-body
                     :start-point (cpv -320.0d0 -240.0d0)
                     :end-point (cpv -320.0d0 240.d0)
                     :thickness 0.0d0
                     :elasticity 1.0d0
                     :friction 1.0d0))
           (shape2 (make-instance 'cp:segment-shape 
                     :body static-body
                     :start-point (cpv 320.0d0 -240.0d0)
                     :end-point (cpv 320.0d0 240.0d0)
                     :thickness 0.0d0
                     :elasticity 1.0d0
                     :friction 1.0d0))
           (shape3 (make-instance 'cp:segment-shape
                     :body static-body
                     :start-point (cpv -320.0d0 -240.0d0)
                     :end-point (cpv 320.0d0 -240.0d0)
                     :thickness 0.0d0
                     :elasticity 1.0d0
                     :friction 1.0d0))
           (circ-body (make-instance 'body
                        :mass 1.0
                        :moment (moment-for-circle 1.0 0.0 5.0 +cpvzero+)
                        :position (cpv -176 240)))
           (poly-body (make-instance 'body
                        :mass 1.0
                        :moment (cp:moment-for-polygon 1.0 '((-15 -15)
                                                             (-15 15)
                                                             (15 15)
                                                             (15 -15))
                                                       cp:+cpvzero+)
                        :position (cpv -220 240)))
           (shape4 (make-instance 'circle-shape :body circ-body
                     :name "CircleShape"
                     :radius 5.0
                     :offset +cpvzero+))
           (shape5 (make-instance 'cp:polygon-shape 
                     :name "PolyShape"
                     :body poly-body
                     :vertices '((-15 -15)
                                 (-15 15)
                                 (15 15)
                                 (15 -15))
                     :offset +cpvzero+
                     :elasticity 0.0d0 :friction 1.5d0)))
      (add-static-object space shape1)
      (add-static-object space shape2)
      (add-static-object space shape3)
      (dotimes (i 50)
        (let* ((j (1+ i))
               (a (cpv (- (* i 10.0d0) 320.0d0)
                       (+ (* i -10.0d0) 240.0d0)))
               (b (cpv (- (* j 10.0d0) 320.0d0)
                       (+ (* i -10.0d0) 240.0d0)))
               (c (cpv (- (* j 10.0d0) 320.0d0)
                       (+ (* j -10.0d0) 240.0d0))))
          (add-static-object space
                             (make-instance 'segment-shape
                               :body static-body
                               :start-point a
                               :end-point b
                               :thickness 0.0d0
                               :elasticity 1.0d0
                               :friction 1.0d0))
          (add-static-object space
                             (make-instance 'segment-shape 
                               :body static-body
                               :start-point b
                               :end-point c
                               :thickness   0.0d0
                               :elasticity 1.0
                               :friction 1.0))))
      (#_cpSpaceRehashStatic (cp::ptr space))
      (add-object space circ-body)
      (add-object space poly-body)
      (add-object space shape4)
      (add-object space shape5)
      (setf (space view) space))))

(defun reset-stair-demo (view)
  (let ((pshape (find-in-space (space view) "PolyShape"))
        (cshape (find-in-space (space view) "CircleShape")))
    (setf (pos (body pshape)) (cpv 0 240))
    (setf (pos (body cshape)) (cpv -176 240))))